home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / LONG.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  4.2 KB  |  117 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; Function to format a text to fit into a given number of columns
  3.  
  4. (provide 'format-long)
  5. (require 'string)
  6. (require 'sequence)
  7. (require 'character "char")
  8.  
  9. (defvar *width-so-far*)
  10.  
  11. ; This function is for situations (like in PROMPT-WITH-DEFAULT)
  12. ; where a string might occasionally get too big but is expected normally
  13. ; to be OK.  It performs a check before calling FORMAT-LONG-TEXT to avoid
  14. ; the overhead of breaking the string up into words and then putting it
  15. ; back together again unnecessarily.
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ; format-text-if-its-too-long 
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20.  
  21. (defun format-text-if-its-too-long (text width)
  22.   (let ((ok (call-reduce-long-text-if-necessary text)))
  23.     (if (> (length ok) width)
  24.       (format-long-text text width)
  25.       text)))
  26.  
  27. ; FORMAT-LONG-TEXT takes for its first argument either a string or a
  28. ; list of strings.  Its second argument is an integer giving the
  29. ; number of columns available for output.  It returns a string with
  30. ; embedded #\newlines containing all the text from the original
  31. ; strings squeezed into the appropriate number of columns.  In the
  32. ; output, each word is followed by exactly one space except a period
  33. ; is followed by two spaces.  No right-justification is performed.
  34. ; This does about what the NMODE command Fill Comment does.
  35.  
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ; format-long-text 
  38. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39.  
  40. (defun format-long-text (text width)
  41.   (setq *width-so-far* 0)
  42.   (let ((list-of-words
  43.      (to-list-of-words (call-reduce-long-text-if-necessary text)))
  44.     (result ""))
  45.        (dolist (word list-of-words)
  46.            (setq result
  47.              (concatenate 'string result
  48.                  (print-word-within-line-width word
  49.                                width))))
  50.        result))
  51.  
  52. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53. ; last-character 
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55.  
  56. (defun last-character (str) (char str (1- (length str))))
  57.  
  58. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59. ; print-word-within-line-width 
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61.  
  62. (defun print-word-within-line-width (word width)
  63.   (let* ((out-str (if (equal (last-character word) #\.)
  64.               (concatenate 'string word "  ")
  65.               (concatenate 'string word " ")))
  66.      (big (length out-str)))
  67.     (setq *width-so-far* (+ *width-so-far* big))
  68.     (if (> *width-so-far* width)
  69.         (progn
  70.          (setq *width-so-far* big)
  71.          (concatenate 'string out-str *newline-string*))
  72.         out-str)))
  73.  
  74. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75. ; call-reduce-long-text-if-necessary 
  76. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77.  
  78. (defun call-reduce-long-text-if-necessary (text)
  79.   (if (listp text) (reduce-long-text text) text))
  80.  
  81. ; Change a list of strings into one really big string
  82.  
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84. ; reduce-long-text 
  85. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86.  
  87. (defun reduce-long-text (strings)
  88.   (let ((big (length strings)))
  89.     (cond
  90.       ((= big 0) "")
  91.       ((= big 1) (car strings))
  92.       ((concatenate 'string 
  93.     (car strings)
  94.     " "
  95.     (reduce-long-text (cdr strings)))))))
  96.  
  97. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98. ; to-list-of-words 
  99. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  100.  
  101. (defun to-list-of-words (string)
  102.   (let ((big (length string)))
  103.        (if (> big 0)
  104.        (let* ((word-start (position-if-not #'whitespacep string))
  105.               (string-minus-leading-whitespace (subseq string word-start))
  106.           (word-end
  107.             (let ((pos (position-if #'whitespacep
  108.                                     string-minus-leading-whitespace)))
  109.                       (if pos
  110.                         (+ word-start pos -1)
  111.                         (length string-minus-leading-whitespace))))
  112.           (word-length (1+ (- word-end word-start))))
  113.          (cons (subseq string-minus-leading-whitespace 0 word-length)
  114.                (to-list-of-words (subseq string (1+ word-end))))))))
  115.  
  116.  
  117.